home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 2 / adb / a-strfix < prev    next >
Text File  |  1996-02-12  |  18KB  |  677 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                    A D A . S T R I N G S . F I X E D                     --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.12 $                             --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. --  Note: This code is derived from the ADAR.CSH public domain Ada 83
  37. --  versions of the Appendix C string handling packages. One change is
  38. --  to avoid the use of Is_In, so that we are not dependent on inlining.
  39. --  Note that the search function implementations are to be found in the
  40. --  auxiliary package Ada.Strings.Search. Also the Move procedure is
  41. --  directly incorporated (ADAR used a subunit for this procedure)
  42.  
  43. with Ada.Strings.Maps; use Ada.Strings.Maps;
  44. with Ada.Strings.Search;
  45.  
  46. package body Ada.Strings.Fixed is
  47.  
  48.    ------------------------
  49.    -- Search Subprograms --
  50.    ------------------------
  51.  
  52.    function Index
  53.      (Source   : in String;
  54.       Pattern  : in String;
  55.       Going    : in Direction := Forward;
  56.       Mapping  : in Maps.Character_Mapping := Maps.Identity)
  57.       return     Natural
  58.    renames Ada.Strings.Search.Index;
  59.  
  60.    function Index
  61.      (Source   : in String;
  62.       Pattern  : in String;
  63.       Going    : in Direction := Forward;
  64.       Mapping  : in Maps.Character_Mapping_Function)
  65.       return     Natural
  66.    renames Ada.Strings.Search.Index;
  67.  
  68.    function Index
  69.      (Source : in String;
  70.       Set    : in Maps.Character_Set;
  71.       Test   : in Membership := Inside;
  72.       Going  : in Direction  := Forward)
  73.       return   Natural
  74.    renames Ada.Strings.Search.Index;
  75.  
  76.    function Index_Non_Blank
  77.      (Source : in String;
  78.       Going  : in Direction := Forward)
  79.       return   Natural
  80.    renames Ada.Strings.Search.Index_Non_Blank;
  81.  
  82.    function Count
  83.      (Source   : in String;
  84.       Pattern  : in String;
  85.       Mapping  : in Maps.Character_Mapping := Maps.Identity)
  86.       return     Natural
  87.    renames Ada.Strings.Search.Count;
  88.  
  89.    function Count
  90.      (Source   : in String;
  91.       Pattern  : in String;
  92.       Mapping  : in Maps.Character_Mapping_Function)
  93.       return     Natural
  94.    renames Ada.Strings.Search.Count;
  95.  
  96.    function Count
  97.      (Source   : in String;
  98.       Set      : in Maps.Character_Set)
  99.       return     Natural
  100.    renames Ada.Strings.Search.Count;
  101.  
  102.    procedure Find_Token
  103.      (Source : in String;
  104.       Set    : in Maps.Character_Set;
  105.       Test   : in Membership;
  106.       First  : out Positive;
  107.       Last   : out Natural)
  108.    renames Ada.Strings.Search.Find_Token;
  109.  
  110.    ---------
  111.    -- "*" --
  112.    ---------
  113.  
  114.    function "*"
  115.      (Left  : in Natural;
  116.       Right : in Character)
  117.       return  String
  118.    is
  119.       Result : String (1 .. Left);
  120.  
  121.    begin
  122.       for J in Result'Range loop
  123.          Result (J) := Right;
  124.       end loop;
  125.  
  126.       return Result;
  127.    end "*";
  128.  
  129.    function "*"
  130.      (Left  : in Natural;
  131.       Right : in String)
  132.       return  String
  133.    is
  134.       Result : String (1 .. Left * Right'Length);
  135.       Ptr    : Integer := 1;
  136.  
  137.    begin
  138.       for J in 1 .. Left loop
  139.          Result (Ptr .. Ptr + Right'Length - 1) := Right;
  140.          Ptr := Ptr + Right'Length;
  141.       end loop;
  142.  
  143.       return Result;
  144.    end "*";
  145.  
  146.    ------------
  147.    -- Delete --
  148.    ------------
  149.  
  150.    function Delete
  151.      (Source  : in String;
  152.       From    : in Positive;
  153.       Through : in Natural)
  154.       return    String
  155.    is
  156.    begin
  157.       if From not in Source'Range
  158.         or else Through > Source'Last
  159.       then
  160.          raise Index_Error;
  161.  
  162.       elsif From > Through then
  163.          return Source;
  164.  
  165.       else
  166.          declare
  167.             Result : String :=
  168.                        Source (Source'First .. From - 1) &
  169.                        Source (Through + 1 .. Source'Last);
  170.  
  171.          begin
  172.             return Result;
  173.          end;
  174.       end if;
  175.    end Delete;
  176.  
  177.    procedure Delete
  178.      (Source  : in out String;
  179.       From    : in Positive;
  180.       Through : in Natural;
  181.       Justify : in Alignment := Left;
  182.       Pad     : in Character := Space)
  183.    is
  184.    begin
  185.       Move (Source  => Delete (Source, From, Through),
  186.             Target  => Source,
  187.             Justify => Justify,
  188.             Pad     => Pad);
  189.    end Delete;
  190.  
  191.    ----------
  192.    -- Head --
  193.    ----------
  194.  
  195.    function Head
  196.      (Source : in String;
  197.       Count  : in Natural;
  198.       Pad    : in Character := Space)
  199.       return   String
  200.    is
  201.       Result : String (1 .. Count);
  202.  
  203.    begin
  204.       if Count < Source'Length then
  205.          Result := Source (Source'First .. Source'First + Count - 1);
  206.  
  207.       else
  208.          Result (1 .. Source'Length) := Source;
  209.  
  210.          for J in Source'Length + 1 .. Count loop
  211.             Result (J) := Pad;
  212.          end loop;
  213.       end if;
  214.  
  215.       return Result;
  216.    end Head;
  217.  
  218.    procedure Head
  219.      (Source  : in out String;
  220.       Count   : in Natural;
  221.       Justify : in Alignment := Left;
  222.       Pad     : in Character := Space)
  223.    is
  224.    begin
  225.       if Count < Source'Length then
  226.          Source := Source (Source'First .. Source'First + Count - 1);
  227.       else
  228.          for J in Source'Length + 1 .. Count loop
  229.             Source (J) := Pad;
  230.          end loop;
  231.       end if;
  232.  
  233.    end Head;
  234.  
  235.    ------------
  236.    -- Insert --
  237.    ------------
  238.  
  239.    function Insert
  240.      (Source   : in String;
  241.       Before   : in Positive;
  242.       New_Item : in String)
  243.       return     String
  244.    is
  245.       Result : String (1 .. Source'Length + New_Item'Length);
  246.  
  247.    begin
  248.       if Before < Source'First or else Before > Source'Last + 1 then
  249.          raise Index_Error;
  250.       end if;
  251.  
  252.       Result := Source (Source'First .. Before - 1) & New_Item &
  253.                 Source (Before .. Source'Last);
  254.       return Result;
  255.    end Insert;
  256.  
  257.    procedure Insert
  258.      (Source   : in out String;
  259.       Before   : in Positive;
  260.       New_Item : in String;
  261.       Drop     : in Truncation := Error)
  262.    is
  263.    begin
  264.       Move (Source => Insert (Source, Before, New_Item),
  265.             Target => Source,
  266.             Drop   => Drop);
  267.    end Insert;
  268.  
  269.    ----------
  270.    -- Move --
  271.    ----------
  272.  
  273.    procedure Move
  274.      (Source  : in  String;
  275.       Target  : out String;
  276.       Drop    : in  Truncation := Error;
  277.       Justify : in  Alignment  := Left;
  278.       Pad     : in  Character  := Space)
  279.    is
  280.       Sfirst  : constant Integer := Source'First;
  281.       Slast   : constant Integer := Source'Last;
  282.       Slength : constant Integer := Source'Length;
  283.  
  284.       Tfirst  : constant Integer := Target'First;
  285.       Tlast   : constant Integer := Target'Last;
  286.       Tlength : constant Integer := Target'Length;
  287.  
  288.       function Is_Padding (Item : String) return Boolean;
  289.       --  Check if Item is all Pad characters, return True if so, False if not
  290.  
  291.       function Is_Padding (Item : String) return Boolean is
  292.       begin
  293.          for J in Item'Range loop
  294.             if Item (J) /= Pad then
  295.                return False;
  296.             end if;
  297.          end loop;
  298.  
  299.          return True;
  300.       end Is_Padding;
  301.  
  302.    --  Start of processing for Move
  303.  
  304.    begin
  305.       if Slength = Tlength then
  306.          Target := Source;
  307.  
  308.       elsif Slength > Tlength then
  309.  
  310.          case Drop is
  311.             when Left =>
  312.                Target := Source (Slast - Tlength + 1 .. Slast);
  313.  
  314.             when Right =>
  315.                Target := Source (Sfirst .. Sfirst + Tlength - 1);
  316.  
  317.             when Error =>
  318.                case Justify is
  319.                   when Left =>
  320.                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
  321.                         Target :=
  322.                           Source (Sfirst .. Sfirst + Target'Length - 1);
  323.                      else
  324.                         raise Length_Error;
  325.                      end if;
  326.  
  327.                   when Right =>
  328.                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
  329.                         Target := Source (Slast - Tlength + 1 .. Slast);
  330.                      else
  331.                         raise Length_Error;
  332.                      end if;
  333.  
  334.                   when Center =>
  335.                      raise Length_Error;
  336.                end case;
  337.  
  338.          end case;
  339.  
  340.       else -- Source'Length < Target'Length
  341.  
  342.          case Justify is
  343.             when Left =>
  344.                Target (Tfirst .. Tfirst + Slength - 1) := Source;
  345.  
  346.                for I in Tfirst + Slength .. Tlast loop
  347.                   Target (I) := Pad;
  348.                end loop;
  349.  
  350.             when Right =>
  351.                for I in Tfirst .. Tlast - Slength loop
  352.                   Target (I) := Pad;
  353.                end loop;
  354.  
  355.                Target (Tlast - Slength + 1 .. Tlast) := Source;
  356.  
  357.             when Center =>
  358.                declare
  359.                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
  360.                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
  361.  
  362.                begin
  363.                   for I in Tfirst .. Tfirst_Fpad - 1 loop
  364.                      Target (I) := Pad;
  365.                   end loop;
  366.  
  367.                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
  368.  
  369.                   for I in Tfirst_Fpad + Slength .. Tlast loop
  370.                      Target (I) := Pad;
  371.                   end loop;
  372.                end;
  373.          end case;
  374.       end if;
  375.    end Move;
  376.  
  377.    ---------------
  378.    -- Overwrite --
  379.    ---------------
  380.  
  381.    function Overwrite
  382.      (Source   : in String;
  383.       Position : in Positive;
  384.       New_Item : in String)
  385.       return     String
  386.    is
  387.    begin
  388.       if Position not in Source'First .. Source'Last + 1 then
  389.          raise Index_Error;
  390.       end if;
  391.  
  392.       declare
  393.          Result_Length : Natural :=
  394.            Integer'Max
  395.              (Source'Length, Position - Source'First + New_Item'Length);
  396.  
  397.          Result : String (1 .. Result_Length);
  398.  
  399.       begin
  400.          Result := Source (Source'First .. Position - 1) & New_Item &
  401.                    Source (Position + New_Item'Length .. Source'Last);
  402.          return Result;
  403.       end;
  404.    end Overwrite;
  405.  
  406.    procedure Overwrite
  407.      (Source   : in out String;
  408.       Position : in Positive;
  409.       New_Item : in String;
  410.       Drop     : in Truncation := Right)
  411.    is
  412.    begin
  413.       Move (Source => Overwrite (Source, Position, New_Item),
  414.             Target => Source,
  415.             Drop   => Drop);
  416.    end Overwrite;
  417.  
  418.    -------------------
  419.    -- Replace_Slice --
  420.    -------------------
  421.  
  422.    function Replace_Slice
  423.      (Source   : in String;
  424.       Low      : in Positive;
  425.       High     : in Natural;
  426.       By       : in String)
  427.       return     String
  428.    is
  429.       Result_Length : Natural;
  430.  
  431.    begin
  432.       if Low > Source'Last + 1 or High < Source'First - 1 then
  433.          raise Index_Error;
  434.       end if;
  435.  
  436.       Result_Length :=
  437.         Source'Length - Integer'Max (High - Low + 1, 0) + By'Length;
  438.  
  439.       declare
  440.          Result : String (1 .. Result_Length);
  441.  
  442.       begin
  443.          if High >= Low then
  444.             Result :=
  445.                Source (Source'First .. Low - 1) & By &
  446.                Source (High + 1 .. Source'Last);
  447.          else
  448.             Result := Source (Source'First .. Low - 1) & By &
  449.                       Source (Low .. Source'Last);
  450.          end if;
  451.          return Result;
  452.       end;
  453.    end Replace_Slice;
  454.  
  455.    procedure Replace_Slice
  456.      (Source   : in out String;
  457.       Low      : in Positive;
  458.       High     : in Natural;
  459.       By       : in String;
  460.       Drop     : in Truncation := Error;
  461.       Justify  : in Alignment  := Left;
  462.       Pad      : in Character  := Space)
  463.    is
  464.    begin
  465.       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
  466.    end Replace_Slice;
  467.  
  468.    ----------
  469.    -- Tail --
  470.    ----------
  471.  
  472.    function Tail
  473.      (Source : in String;
  474.       Count  : in Natural;
  475.       Pad    : in Character := Space)
  476.       return   String
  477.    is
  478.       Result : String (1 .. Count);
  479.  
  480.    begin
  481.       if Count < Source'Length then
  482.          Result := Source (Source'Last - Count + 1 .. Source'Last);
  483.  
  484.       --  Pad on left
  485.  
  486.       else
  487.          for J in 1 .. Count - Source'Length loop
  488.             Result (J) := Pad;
  489.          end loop;
  490.  
  491.          Result (Count - Source'Length + 1 .. Count) := Source;
  492.       end if;
  493.  
  494.       return Result;
  495.    end Tail;
  496.  
  497.    procedure Tail
  498.      (Source  : in out String;
  499.       Count   : in Natural;
  500.       Justify : in Alignment := Left;
  501.       Pad     : in Character := Space)
  502.    is
  503.       Temp : String (1 .. Source'Length);
  504.  
  505.    begin
  506.       --  raise Program_Error;
  507.       Temp (1 .. Source'Length) := Source;
  508.       if Count < Source'Length then
  509.          Source := Temp (Temp'Last - Count + 1 .. Temp'Last);
  510.  
  511.       --  Pad on left
  512.  
  513.       else
  514.          for J in 1 .. Count - Temp'Length loop
  515.             Source (J) := Pad;
  516.          end loop;
  517.  
  518.          Source (Count - Temp'Length + 1 .. Count) := Temp;
  519.       end if;
  520.  
  521.    end Tail;
  522.  
  523.    ---------------
  524.    -- Translate --
  525.    ---------------
  526.  
  527.    function Translate
  528.      (Source  : in String;
  529.       Mapping : in Maps.Character_Mapping)
  530.       return    String
  531.    is
  532.       Result : String (1 .. Source'Length);
  533.  
  534.    begin
  535.       for J in Source'Range loop
  536.          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
  537.       end loop;
  538.  
  539.       return Result;
  540.    end Translate;
  541.  
  542.    procedure Translate
  543.      (Source  : in out String;
  544.       Mapping : in Maps.Character_Mapping)
  545.    is
  546.    begin
  547.       for J in Source'Range loop
  548.          Source (J) := Value (Mapping, Source (J));
  549.       end loop;
  550.    end Translate;
  551.  
  552.    function Translate
  553.      (Source  : in String;
  554.       Mapping : in Maps.Character_Mapping_Function)
  555.       return    String
  556.    is
  557.       Result : String (1 .. Source'Length);
  558.  
  559.    begin
  560.       for J in Source'Range loop
  561.          Result (J - (Source'First - 1)) := Mapping.all (Source (J));
  562.       end loop;
  563.  
  564.       return Result;
  565.    end Translate;
  566.  
  567.    procedure Translate
  568.      (Source  : in out String;
  569.       Mapping : in Maps.Character_Mapping_Function)
  570.    is
  571.    begin
  572.       for J in Source'Range loop
  573.          Source (J) := Mapping.all (Source (J));
  574.       end loop;
  575.    end Translate;
  576.  
  577.    ----------
  578.    -- Trim --
  579.    ----------
  580.  
  581.    function Trim
  582.      (Source : in String;
  583.       Side   : in Trim_End)
  584.       return   String
  585.    is
  586.       Low, High : Integer;
  587.  
  588.    begin
  589.       Low  := Index_Non_Blank (Source, Forward);
  590.  
  591.       --  All blanks case
  592.  
  593.       if Low = 0 then
  594.          return "";
  595.  
  596.       --  At least one non-blank
  597.  
  598.       else
  599.          High := Index_Non_Blank (Source, Backward);
  600.  
  601.          case Side is
  602.             when Strings.Left =>
  603.                return Source (Low .. Source'Last);
  604.  
  605.             when Strings.Right =>
  606.                return Source (Source'First .. High);
  607.  
  608.             when Strings.Both =>
  609.                return Source (Low .. High);
  610.          end case;
  611.       end if;
  612.    end Trim;
  613.  
  614.    procedure Trim
  615.      (Source  : in out String;
  616.       Side    : in Trim_End;
  617.       Justify : in Alignment := Left;
  618.       Pad     : in Character := Space)
  619.    is
  620.    begin
  621.       Move (Trim (Source, Side),
  622.             Source,
  623.             Justify => Justify,
  624.             Pad => Space);
  625.    end Trim;
  626.  
  627.    function Trim
  628.      (Source : in String;
  629.       Left   : in Maps.Character_Set;
  630.       Right  : in Maps.Character_Set)
  631.       return   String
  632.    is
  633.       High, Low : Integer;
  634.  
  635.    begin
  636.       Low := Index (Source, Set => Left, Test  => Outside, Going => Forward);
  637.  
  638.       --  Case where source comprises only characters in Left
  639.  
  640.       if Low = 0 then
  641.          return "";
  642.       end if;
  643.  
  644.       High :=
  645.         Index (Source, Set => Right, Test  => Outside, Going => Backward);
  646.  
  647.       --  Case where source comprises only characters in Right
  648.  
  649.       if High = 0 then
  650.          return "";
  651.       end if;
  652.  
  653.       declare
  654.          Result : String (1 .. High - Low + 1);
  655.  
  656.       begin
  657.          Result := Source (Low .. High);
  658.          return Result;
  659.       end;
  660.    end Trim;
  661.  
  662.    procedure Trim
  663.      (Source  : in out String;
  664.       Left    : in Maps.Character_Set;
  665.       Right   : in Maps.Character_Set;
  666.       Justify : in Alignment := Strings.Left;
  667.       Pad     : in Character := Space)
  668.    is
  669.    begin
  670.       Move (Source  => Trim (Source, Left, Right),
  671.             Target  => Source,
  672.             Justify => Justify,
  673.             Pad     => Pad);
  674.    end Trim;
  675.  
  676. end Ada.Strings.Fixed;
  677.